home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / INITOBJ.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  20KB  |  604 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "attr.h"
  16. #include "setp.h"
  17. #include "gutilp.h"
  18. #include "gmiscp.h"
  19. #include "smiscp.h"
  20. #include "gnodesp.h"
  21. #include "initobjp.h"
  22.  
  23. static Tuple proc_init_rec(Symbol, Tuple, Node, Node);
  24. static Node initialization_proc(Symbol, Symbol, Tuple, Tuple);
  25. static Tuple build_comp_names(Node);
  26. static Node remove_discr_ref(Node, Node);
  27.  
  28. Node build_proc_init_ara(Symbol type_name)                /*;build_proc_init_ara*/
  29. {
  30.     /*
  31.      *  This is the   main procedure for  building default  initialization
  32.      *  procedures for array  types. Those  initialization  procedures are
  33.      *  built if  the type  given  contains  some subcomponent for which a
  34.      *  default initialization exists (at any level of nesting),  or if it
  35.      *  has determinants.
  36.      *  Note that scalar objects are not initialized at all, which implies
  37.      *  that they get whatever initial value is in that location in memory
  38.      *  This saves some time in object creation.
  39.      *
  40.      *  All init. procedures  have an 'out' parameter that  designates the
  41.      *  object being initialized (the space has already been allocated).
  42.      *
  43.      */
  44.  
  45.     int        side_effect;
  46.     Tuple    tup, formals, subscripts;
  47.     Symbol    c_type, ip, index_t, proc_name, index_sym;
  48.     Node    one_component, init_stmt, out_param, i_nodes, d_node, iter_node;
  49.     Fortup    ft1;
  50.     Node    iterator, index_node;
  51.  
  52. #ifdef TRACE
  53.     if (debug_flag) {
  54.         gen_trace_symbol("BUILD_PROC_INIT_ARR", type_name);
  55.     }
  56. #endif
  57.  
  58.     side_effect = FALSE;     /* Let's hope... TBSL */
  59.  
  60.     tup = SIGNATURE(type_name);
  61.     c_type    = (Symbol) tup[2];
  62.     one_component = new_node(as_index);
  63.  
  64.     ip = INIT_PROC(base_type(c_type));
  65.     if (ip != (Symbol)0 ){
  66.         /* Use the initialization procedure for the component type */
  67.         init_stmt = (Node) build_init_call(one_component, ip, c_type, OPT_NODE);
  68.     }
  69.     else if (is_task_type(c_type)) {
  70.         /* initialization is task creation. */
  71.         init_stmt =
  72.           new_assign_node(one_component, new_create_task_node(c_type));
  73.     }
  74.     else if (is_access_type(c_type)) {
  75.         /* default value is the null pointer. */
  76.         init_stmt = new_assign_node(one_component, new_null_node(c_type));
  77.     }
  78.     else {
  79.         init_stmt = (Node) 0;
  80.     }
  81.  
  82.     if (init_stmt != (Node)0) {
  83.         /* body of initialization procedure is a loop over the indices */
  84.         /* allocating each component. Generate loop variables and code */
  85.         /* for iteration, using the attributes of the type. */
  86.  
  87.         proc_name = new_unique_name("type_name+INIT");
  88.         out_param = new_param_node("param_type_name", proc_name,
  89.            type_name, na_out);
  90.         generate_object(N_UNQ(out_param));
  91.         formals               = tup_new1((char *) out_param);
  92.         subscripts            = tup_new(0);
  93.         FORTUP(index_t=(Symbol), index_types(type_name), ft1);
  94.             /*index          = index_t + 'INDEX';*/
  95.             index_sym          = new_unique_name("index_t+INDEX");
  96.             NATURE (index_sym) = na_obj;
  97.             TYPE_OF(index_sym) = index_t;
  98.             subscripts = tup_with(subscripts, (char *)new_name_node(index_sym));
  99.         ENDFORTUP(ft1);
  100.  
  101.         i_nodes         = new_node(as_list);
  102.         /* need tup_copy since subscripts used destructively below */
  103.         N_LIST(i_nodes) = tup_copy(subscripts);
  104.  
  105.         /* Build the tree for the one_component of the array. */
  106.         N_AST1(one_component) = out_param;
  107.         N_AST2(one_component) = i_nodes;
  108.         N_TYPE(one_component) = c_type;
  109.  
  110.         while (tup_size(subscripts)) {
  111.             /* Build loop from innermost index outwards. The iterations */
  112.             /* span the ranges of the array being initialized. */
  113.  
  114.             /* dimension spanned by this loop: */
  115.             d_node   = new_ivalue_node(int_const(tup_size(subscripts)), 
  116.               symbol_integer);
  117.             iterator = new_attribute_node(ATTR_O_RANGE,
  118.               new_name_node(N_UNQ(out_param)), d_node, type_name);
  119.  
  120.             index_node = (Node) tup_frome(subscripts);
  121.             iter_node        = new_node(as_for);
  122.             N_AST1(iter_node) = index_node;
  123.             N_AST2(iter_node) = iterator;
  124.  
  125.             init_stmt = new_loop_node(OPT_NODE, iter_node, 
  126.               tup_new1((char *)init_stmt));
  127.         }
  128.  
  129.         INIT_PROC(type_name) = proc_name;
  130.         return initialization_proc(proc_name, type_name,
  131.           formals, tup_new1((char *) init_stmt));
  132.     }
  133.     else {
  134.         return OPT_NODE;
  135.     }
  136.  
  137. }
  138.  
  139. Node build_proc_init_rec(Symbol type_name)                /*;build_proc_init_rec*/
  140. {
  141.     /*
  142.      *  This is the   main procedure for  building default  initialization
  143.      *  procedures for record  types. Those initialization  procedures are
  144.      *  built if  the type  given  contains  some subcomponent for which a
  145.      *  default initialization exists (at any level of nesting),  or if it
  146.      *  has determinants.
  147.      *  Note that scalar objects are not initialized at all, which implies
  148.      *  that they get whatever initial value is in that location in memory
  149.      *  This saves some time in object creation.
  150.      *
  151.      *  All init. procedures  have an 'out' parameter that  designates the
  152.      *  object begin initialized (the space has already been allocated).
  153.      *
  154.      */
  155.  
  156.     int        side_effect;
  157.     Node    invar_node; /* TBSL: is invar_node local??*/
  158.     Tuple    stmts, tup, nstmts, formals, invariant_fields;
  159.     Tuple    discr_list; /* is this local ?? TBSL */
  160.     Fortup    ft1;
  161.     Symbol    d, proc_name;
  162.     Node    param, var_node, out_param;
  163.  
  164.     Node    node, node1, node2, discr_value_node;
  165. #ifdef TRACE
  166.     if (debug_flag)
  167.         gen_trace_symbol("BUILD_PROC_INIT_REC", type_name);
  168. #endif
  169.  
  170.     side_effect = FALSE;     /* Let's hope... TBSL */
  171.  
  172.     /*
  173.      * The initialization procedure for records has the usual out param.,
  174.      * and one in parameter per discriminant. The CONSTRAINED flag is the
  175.      * first of the discriminants
  176.      */
  177.     proc_name = new_unique_name("Init_ type_name");
  178.     out_param = new_param_node("param_type_name", proc_name, type_name, na_out);
  179.     generate_object(proc_name);
  180.     generate_object(N_UNQ(out_param));
  181.     tup = SIGNATURE(type_name);
  182.     invar_node = (Node) tup[1];
  183.     var_node = (Node) tup[2];
  184.     discr_list = (Tuple) tup[3];
  185.     invariant_fields = build_comp_names(invar_node);
  186.  
  187.     stmts = tup_new(0);
  188.     if (tup_size(discr_list)) {
  189.         /* Generate formal parameters for each. The body of the procedure */
  190.         /* assigns them to the field of the object. */
  191.         /* Note: the 'constrained' field is part of the discriminants. */
  192.  
  193.         formals = tup_new(0);
  194.         FORTUP(d=(Symbol), discr_list, ft1);
  195.             param = new_param_node("param_type_name", proc_name, TYPE_OF(d),
  196.               na_in);
  197.             generate_object(N_UNQ(param));
  198.             formals = tup_with(formals, (char *) param );
  199.             stmts = tup_with(stmts,
  200.               (char *) new_assign_node(new_selector_node(out_param, d), param));
  201.             discr_value_node = new_selector_node (out_param, d);
  202.  
  203.             /* generate code in order to test if the value of discriminant is
  204.              * compatible with its subtype
  205.              */
  206.  
  207.             node1 = new_attribute_node(ATTR_T_FIRST, new_name_node(TYPE_OF(d)),
  208.               OPT_NODE, TYPE_OF(d));
  209.             node2 = new_attribute_node(ATTR_T_LAST, new_name_node(TYPE_OF(d)),
  210.               OPT_NODE, TYPE_OF(d));
  211.             node = node_new (as_list);
  212.             make_if_node(node,
  213.               tup_new1((char *) new_cond_stmts_node( new_binop_node(symbol_or,
  214.                  new_binop_node(symbol_lt, discr_value_node, node1,
  215.                  symbol_boolean),
  216.                 new_binop_node(symbol_gt, discr_value_node, node2,
  217.                  symbol_boolean),
  218.                 symbol_boolean),
  219.                 new_raise_node(symbol_constraint_error))), OPT_NODE);
  220.             stmts = tup_with(stmts, (char *) node);
  221.         ENDFORTUP(ft1);
  222.         formals = tup_with(formals, (char *) out_param );
  223.  
  224.         /* if there are default expressions for any other components, */
  225.         /* further initialization steps are needed. */
  226.         tup = proc_init_rec(type_name, invariant_fields, var_node, out_param);
  227.         /*stmts += proc_init_rec(invariant_fields, var_node, out_param);*/
  228.         nstmts = tup_add(stmts, tup);
  229.         tup_free(stmts); 
  230.         tup_free(tup); 
  231.         stmts = nstmts;
  232.     }
  233.     else {
  234.         /* record without discriminants. There may still be default values */
  235.         /* for some components. */
  236.         formals = tup_new1((char *) out_param);
  237.         stmts   = proc_init_rec(type_name,invariant_fields,var_node, out_param);
  238.     }
  239.     if (tup_size(stmts)) {
  240.         INIT_PROC(type_name) = proc_name;
  241.         return initialization_proc(proc_name, type_name, formals, stmts);
  242.     }
  243.     else {
  244.         return OPT_NODE;
  245.     }
  246. }
  247.  
  248. static Tuple proc_init_rec(Symbol ty